Celestin Apprentice 2

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Pascal / Applications / NIH Image 1.55 / Source / File2.p < prev next >

Wrap

Text File | 1994-04-25 | 69.5 KB | 2,318 lines | [TEXT/PJMM]

unit File2; {Routines used by NIH Image for printing plus a few additional File Menu routines.} interface uses QuickDraw, Palettes, PrintTraps, globals, Utilities, Graphics, Lut; procedure GetInfo; procedure DoPageSetup; procedure Print (ShowDialog: boolean); procedure SetHalftone; function OpenMacPaint (fname: str255; vnum: integer): boolean; procedure TypeMismatch (fname: str255); procedure SaveAsMacPaint (fname: str255; RefNum: integer); function GetTextFile (var name: str255; var RefNum: integer): boolean; procedure InitTextInput (name: str255; RefNum: integer); procedure GetLineFromText (var rLine: RealLine; var count: integer); function ImportTextFile (name: str255; RefNum: integer): boolean; procedure PlotXYZ; procedure SaveSettings; procedure ExportAsText (fname: str255; RefNum: integer); procedure ExportMeasurements (fname: str255; RefNum: integer); procedure Swap2Bytes (var i: integer); function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean; function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean; procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt); procedure GetTiffColorMap (f: integer); function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr; function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer; procedure SaveLUT (fname: str255; RefNum: integer); procedure SaveColorTable (fname: str255; RefNum: integer); procedure ExportCoordinates (fname: str255; RefNum: integer); procedure SaveOutline (fname: str255; RefNum: integer); procedure OpenOutline (fname: str255; RefNum: integer); function CheckIO (err: OSerr): integer; function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean; procedure GetXUnits (UnitsKind: UnitsType); procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: double); implementation var gstr: str255; {$PUSH} {$D-} procedure PrintErrCheck; var err: integer; ticks: LongInt; begin err := PrError; if err < 0 then beep; end; procedure DoPageSetup; var result: boolean; begin PrOpen; if PrintRecord = nil then begin PrintRecord := THPrint(NewHandle(SizeOF(TPrint))); PrintDefault(PrintRecord); end; if PrError = NoErr then begin result := PrValidate(PrintRecord); result := PrStlDialog(PrintRecord); end; PrClose; end; procedure PrintHalftone; const PostScriptBegin = 190; PostScriptEnd = 191; PostScriptHandle = 192; TextIsPostScript = 194; var HexBufH: handle; hloc, vloc, HexCount, iheight, iwidth, hstart, vstart: integer; Height, Width, eof, angle, freq: str255; aLine: LineType; HexBuf: packed array[0..4200] of char; err: OSErr; table: LookupTable; procedure PutHEX (byt: integer); var i, LowByte, HighByte, tmp: integer; h: char; begin if not info^.IdentityFunction then byt := table[byt]; byt := 255 - byt; LowByte := byt mod 16; byt := byt div 16; HighByte := byt mod 16; for i := 1 to 2 do begin if i = 1 then tmp := HighByte else tmp := LowByte; case tmp of 0: h := '0'; 1: h := '1'; 2: h := '2'; 3: h := '3'; 4: h := '4'; 5: h := '5'; 6: h := '6'; 7: h := '7'; 8: h := '8'; 9: h := '9'; 10: h := 'a'; 11: h := 'b'; 12: h := 'c'; 13: h := 'd'; 14: h := 'e'; 15: h := 'f'; end; hexbuf[HexCount] := h; HexCount := HexCount + 1; if HexCount mod 80 = 0 then begin HexBuf[HexCount] := cr; HexCount := HexCount + 1 end; end; end; begin with info^ do begin if not IdentityFunction then GetLookupTable(table); MoveTo(-1, -1); LineTo(-1, -1); {Nothing prints without this dummy dot!} PicComment(PostScriptBegin, 0, nil); {See Tech Note #91} PicComment(TextIsPostScript, 0, nil); NumToString(HalftoneFrequency, freq); NumToString(HalftoneAngle, angle); if HalftoneDotFunction then DrawString(concat(freq, ' ', angle, ' {dup mul exch dup mul add 1 exch sub} setscreen')) else DrawString(concat(freq, ' ', angle, ' {pop} setscreen')); DrawString('0 0 translate'); with RoiRect do begin iwidth := right - left; if iwidth > MaxLine then iwidth := MaxLine; iheight := bottom - top; hstart := left; vstart := top; end; NumToString(iwidth, width); NumToString(iheight, height); DrawString(concat(width, ' ', height, ' scale')); DrawString(concat('/PicStr ', width, ' string def')); DrawString(concat(width, ' ', height, ' 8 [', width, ' 0 0 ', height, ' 0 0]')); DrawString('{currentfile PicStr readhexstring pop} image'); for vloc := vstart to vstart + iheight - 1 do begin GetLine(hstart, vloc, iwidth, aline); HexCount := 0; for hloc := 0 to iwidth - 1 do PutHex(aline[hloc]); HexBuf[HexCount] := cr; HexCount := HexCount + 1; err := PtrToHand(@HexBuf, HexBufH, HexCount); if err <> noErr then exit(PrintHalftone); PicComment(PostScriptHandle, HexCount, HexBufH); DisposHandle(HexBufH); Show2Values(vloc - vstart, iheight); if CommandPeriod then begin beep; eof := chr(4); DrawString(eof); exit(PrintHalftone) end; end; end; end; procedure PrintTheImage (PageWidth, PageHeight: integer); var PrintRect: rect; Width, Height: integer; procedure ScaleToFitPage; var hscale, vscale, scale: real; begin hscale := PageWidth / width; vscale := PageHeight / height; if hscale <= vscale then scale := hscale else scale := vscale; width := trunc(scale * width); height := trunc(scale * height); end; procedure CenterOnPage; begin with PrintRect do begin left := 0; top := 0; if width < PageWidth then left := (PageWidth - width) div 2; if height < PageHeight then top := (Pageheight - height) div 2; right := left + width; bottom := top + height; end; end; begin if isLaserWriter and (not OptionKeyDown) and (not OptionKeyWasDown) and (not DriverHalftoning) then PrintHalftone else with info^ do begin LoadLUT(cTable); hlock(handle(osPort^.portPixMap)); with RoiRect do begin width := right - left; height := bottom - top; end; if (width > PageWidth) or (height > PageHeight) then ScaleToFitPage; CenterOnPage; if BitAnd(thePort^.portBits.rowBytes, $8000) = $8000 then begin {Assume driver understands Color QD} hlock(handle(CGrafPort(ThePort^).PortPixMap)); CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPort(ThePort^).PortPixMap)^^, RoiRect, PrintRect, SrcCopy, nil); hunlock(handle(CGrafPort(ThePort^).PortPixMap)) end else CopyBits(BitMapHandle(osPort^.portPixMap)^^, thePort^.PortBits, RoiRect, PrintRect, SrcCopy, nil); hunlock(handle(osPort^.portPixMap)); end; end; procedure PrintTextBuffer (PageHeight: integer; var PrintPort: TPPrPort); const LineInc = 13; var vloc, i, LineCount, CharCount, LinesPerPage, MaxCount: integer; aLine: str255; begin ClipTextInBuffer := false; LinesPerPage := PageHeight div LineInc; vloc := LineInc; LineCount := 0; CharCount := 0; TextFont(Monaco); TextSize(9); if WhatToPrint = PrintText then MaxCount := 85 else MaxCount := 255; i := 1; repeat CharCount := 0; while (TextBufP^[i] <> cr) and (CharCount < MaxCount) and (i <= TextBufSize) do begin CharCount := CharCount + 1; aLine[CharCount] := TextBufP^[i]; i := i + 1; end; if TextBufP^[i] = cr then i := i + 1 else if CharCount = MaxCount then begin while (aLine[CharCount] <> ' ') and (CharCount > (MaxCount - 15)) do begin CharCount := CharCount - 1; i := i - 1; end; if TextBufP^[i] = ' ' then i := i + 1; end; aLine[0] := chr(CharCount); MoveTo(0, vloc); DrawString(aLine); vLoc := vLoc + LineInc; LineCount := LineCount + 1; if LineCount >= LinesPerPage then begin LineCount := 0; if i < TextBufSize then begin PrClosePage(PrintPort); PrintErrCheck; PrOpenPage(PrintPort, nil); vloc := LineInc end; end; until i > TextBufSize; end; procedure DoPrintText (PageHeight: integer; var PrintPort: TPPrPort); var ByteCount: LongInt; begin if TextInfo <> nil then with TextInfo^.TextTE^^ do begin ByteCount := TELength; BlockMove(hText^, ptr(TextBufP), ByteCount); TextBufSize := ByteCount; PrintTextBuffer(PageHeight, PrintPort); end; end; procedure Print (ShowDialog: boolean); var err, i, LinesToPrint: Integer; tPort: GrafPtr; PrintPort: TPPrPort; PrintStatusRec: TPrStatus; prect: rect; result: boolean; begin if WhatToPrint = PrintImage then SelectAll(false); if (WhatToPrint = PrintImage) or (WhatToPrint = PrintSelection) then begin if OpPending then KillRoi; with info^.RoiRect do LinesToPrint := bottom - top; if not DriverHalftoning then begin DrawLabels('Line:', 'Total:', ''); Show2Values(0, LinesToPrint); end; end; GetPort(tPort); PrOpen; if PrintRecord = nil then begin PrintRecord := THPrint(NewHandle(SizeOF(TPrint))); PrintDefault(PrintRecord); end; if PrError = NoErr then begin InitCursor; result := PrValidate(PrintRecord); isLaserWriter := BSR(PrintRecord^^.prStl.wDev, 8) = 3; prect := PrintRecord^^.prInfo.rPage; if ShowDialog then result := PrJobDialog(PrintRecord) else result := true; if not DriverHalftoning then ShowMessage(CmdPeriodToStop); ShowWatch; if result then for i := 1 to PrintRecord^^.PrJob.icopies do begin PrintPort := PrOpenDoc(PrintRecord, nil, nil); PrintErrCheck; Printing := true; PrOpenPage(PrintPort, nil); if PrError = NoErr then case WhatToPrint of PrintImage, PrintSelection: PrintTheImage(prect.right, prect.bottom); PrintMeasurements: begin CopyResultsToBuffer(1, mCount, true); PrintTextBuffer(prect.Bottom, PrintPort); UnsavedResults := false; end; PrintPlot: DrawPlot; PrintHistogram: DrawHistogram; PrintText: DoPrintText(prect.Bottom, PrintPort); end; Printing := false; PrClosePage(PrintPort); PrintErrCheck; PrCloseDoc(PrintPort); PrintErrCheck; if PrintRecord^^.prJob.bJDocLoop = bSpoolLoop then PrPicFile(PrintRecord, nil, nil, nil, PrintStatusRec); end; end; PrClose; SetPort(tPort); if WhatToPrint = PrintImage then KillRoi; ShowMessage(' '); end; procedure SetHalftone; const FrequencyID = 8; AngleID = 10; DotID = 4; LineID = 5; var mylog: DialogPtr; item, i, ignore, SaveFrequency, SaveAngle: integer; SaveFunction: boolean; str: str255; begin if DriverHalftoning then begin PutMessage('Custom halftoning is only available when Custom Grayscale Halftoning is checked in the Preferences dialog box.'); exit(SetHalftone); end; SaveFrequency := HalftoneFrequency; SaveAngle := HalftoneAngle; SaveFunction := HalftoneDotFunction; mylog := GetNewDialog(30, nil, pointer(-1)); SetDNum(MyLog, FrequencyID, HalftoneFrequency); SelIText(MyLog, FrequencyID, 0, 32767); SetDNum(MyLog, AngleID, HalftoneAngle); OutlineButton(MyLog, ok, 16); if HalftoneDotFunction then SetDialogItem(mylog, DotID, 1) else SetDialogItem(mylog, LineID, 1); repeat ModalDialog(nil, item); if item = FrequencyID then HalftoneFrequency := GetDNum(MyLog, FrequencyID); if item = AngleID then begin HalftoneAngle := GetDNum(MyLog, AngleID); if (HalftoneAngle < 0) or (HalftoneAngle > 180) then begin beep; HalftoneAngle := SaveAngle; end; end; if (item >= DotID) and (item <= LineID) then begin for i := DotID to LineID do SetDialogItem(mylog, i, 0); SetDialogItem(mylog, item, 1); HalftoneDotFunction := item = DotID; end; until (item = ok) or (item = cancel); DisposDialog(mylog); if item = cancel then begin HalftoneFrequency := SaveFrequency; HalftoneAngle := SaveAngle; HalftoneDotFunction := SaveFunction; end; end; {$POP} procedure GetFileInfo (name: str255; vnum: integer; var DateCreated, LastModified: str255); var FileParmBlock: ParmBlkPtr; theErr: OSErr; DateVar, TimeVar: str255; Secs: LongInt; begin DateCreated := ''; new(FIleParmBlock); if FileParmBlock <> nil then with FileParmBlock^ do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := vnum; ioFVersNum := 0; ioFDirIndex := 0; theErr := PBGetFInfo(FileParmBlock, false); if theErr = NoErr then begin Secs := ioFlCrDat; IUDateString(Secs, abbrevDate, DateVar); IUTimeString(Secs, true, TimeVar); DateCreated := concat(DateVar, ' ', TimeVar); Secs := ioFlMDDat; IUDateString(Secs, abbrevDate, DateVar); IUTimeString(Secs, true, TimeVar); LastModified := concat(DateVar, ' ', TimeVar); end; Dispose(FileParmBlock); end; end; procedure GetVolumnInfo (vnum: integer; var VolumnName: str255; var FreeSpace: LongInt); var theErr: OSErr; SPtr: StringPtr; VolParmBlock: ParmBlkPtr; begin VolumnName := ''; new(SPtr); new(VolParmBlock); if (SPtr <> nil) and (VolParmBlock <> nil) then with VolParmBlock^ do begin SPtr^ := ''; ioVRefNum := vnum; ioNamePtr := SPtr; ioCompletion := nil; ioVolIndex := -1; theErr := PBGetVInfo(VolParmBlock, false); VolumnName := ioNamePtr^; FreeSpace := ioVAlBlkSiz * ioVFrBlk; dispose(SPtr); dispose(VolParmBlock); end; end; function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var err: OSErr; f: integer; VolumnName: str255; FreeSpace, ExistingFileSize, NeededSize: LongInt; begin with info^ do begin ExistingFileSize := 0; RoomForFile := true; err := fsopen(fname, RefNum, f); if err = 0 then begin err := GetEOF(f, ExistingFileSize); err := fsClose(f); end; if ExistingFileSize <> 0 then begin if SavingSelection then NeededSize := LongInt(slines) * sPixelsPerLine else NeededSize := ImageSize; if StackInfo <> nil then with StackInfo^ do NeededSize := NeededSize * nSlices + nSlices * SizeOf(StackIFDType); GetVolumnInfo(RefNum, VolumnName, FreeSpace); if (NeededSize - ExistingFileSize + 8192) > FreeSpace then begin PutMessage('There is not enough free space on this disk to save this image.'); RoomForFile := false; end; end; end; end; procedure GetInfo; var name, str, DateCreated, LastModified, VolumnName, str2: str255; hloc, vloc, InfoWidth, InfoHeight: integer; SaveRoiShowing: boolean; FreeSpace, DataSize: LongInt; SaveForeIndex, SaveBackIndex: integer; ImageInfo, InfoWindowInfo: InfoPtr; x1, y1, x2, y2, ulength, clength: real; SaveGDevice: GDHandle; procedure NewLine; begin vloc := vloc + 13; MoveTo(hloc, vloc); end; procedure NewParagraph; begin vloc := vloc + 18; MoveTo(hloc, vloc); end; begin InfoWidth := 260; InfoHeight := 260; with info^ do begin if RoiShowing then InfoHeight := InfoHeight + 50; if RoiShowing and (RoiType = LineRoi) then InfoHeight := InfoHeight + 20; if vref <> 0 then InfoHeight := InfoHeight + 60; name := concat('Info About ', title); SaveRoiShowing := RoiShowing; end; SaveForeIndex := ForegroundIndex; SaveBackIndex := BackgroundIndex; SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); ImageInfo := info; if NewPicWindow(name, InfoWidth, InfoHeight) then with ImageInfo^ do begin InfoWindowInfo := Info; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(info^.osPort)); TextFont(ApplFont); TextSize(9); hloc := 15; vloc := 10; NewLine; DrawBString('Name: '); DrawString(title); NewParagraph; DrawBString('Width: '); DrawXDimension(PixelsPerLine, 0); NewLine; DrawBString('Height: '); DrawYDimension(nlines, 0); if StackInfo <> nil then begin NewLine; DrawBString('Depth: '); DrawLong(StackInfo^.nSlices); end; NewLine; DrawBString('Size: '); if StackInfo <> nil then DataSize := PixMapSize * StackInfo^.nSlices else DataSize := PixMapSize; DrawLong((DataSize + 511) div 1024); DrawString('K'); NewParagraph; GetFileInfo(title, vref, DateCreated, LastModified); {DateCreated:='';} if DateCreated <> '' then begin DrawBString('Creation Date: '); DrawString(DateCreated); NewLine; DrawBString('Last Modified: '); DrawString(LastModified); NewLine; end; if iVersion > 0 then begin DrawBString('Version: '); DrawString('Created by NIH Image '); DrawReal(iVersion / 100.0, 1, 2); NewLine; end; if vref <> 0 then begin GetVolumnInfo(vref, VolumnName, FreeSpace); if VolumnName <> '' then begin DrawBString('Volume: '); DrawString(VolumnName); DrawString(' ('); DrawLong(FreeSpace div 1024); DrawString('K free)'); NewParagraph; end; end; DrawBString('Type: '); if StackInfo <> nil then str := concat('Stack (', long2str(StackInfo^.nSlices), ' slices)') else begin case PictureType of pdp11: str := 'PDP-11'; NewPicture: str := 'New'; normal: str := 'Normal'; PictFile: str := 'PICT'; TiffFile, InvertedTIFF: str := 'TIFF'; Leftover: str := 'Left Over'; imported: begin if DataType = EightBits then str := 'Imported 8-bit image' else str := 'Imported 16-bit image'; end; FrameGrabberType: str := 'Camera'; BlankField: str := 'Blank Field'; ScionType: str := 'Camera(Scion)'; otherwise ; end; if BinaryPic then str := concat(str, ' (Binary)'); end; DrawString(str); if StackInfo <> nil then with StackInfo^ do if SliceSpacing <> 0.0 then begin NewLine; DrawBString('Slice Spacing: '); RealToString(SliceSpacing, 1, 1, str); DrawString(str); DrawString(' pixels'); end; NewLine; DrawBString('Lookup Table: '); case LutMode of PseudoColor: str := concat('Pseudocolor (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')'); GrayScale: str := concat('Grayscale (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')'); ColorLut: str := 'Color'; CustomGrayscale: str := 'Custom Grayscale'; otherwise end; DrawString(str); NewLine; DrawBString('Magnification: '); if ScaleToFitWindow then begin DrawReal(magnification, 1, 2); DrawString(' (Scale to Window Mode)') end else begin DrawReal(magnification, 1, 0); DrawString(':1') end; NewLine; DrawBString('Scale: '); if SpatiallyCalibrated then begin DrawReal(xSpatialScale, 1, 3); DrawString(' pixels per '); DrawString(xUnit); if PixelAspectRatio <> 1.0 then begin NewLine; DrawBString('Pixel Aspect Ratio: '); DrawReal(PixelAspectRatio, 1, 4); end; end else DrawString('None'); if DensityCalibrated then begin NewLine; DrawBString('Unit of Measure: '); if UnitOfMEasure = '' then DrawString('None') else DrawString(UnitOfMeasure) end; NewParagraph; DrawBString('Free RAM: '); DrawLong(FreeMem div 1024); DrawString('K'); NewLine; DrawBString('Largest Free Block: '); DrawLong(MaxBlock div 1024); DrawString('K'); if FrameGrabber <> NoFrameGrabber then begin NewLine; DrawBString('Frame Grabber: '); case FrameGrabber of QuickCapture: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Data Translation QuickCapture'); end; ScionLG3: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' SCION LG-3 ('); DrawLong(MaxLG3Frames div 2); DrawString(' MB)'); end end; end; NewParagraph; if RoiType <> NoRoi then begin DrawBString('Selection Type: '); case RoiType of PolygonRoi: DrawString('Polygon'); FreehandRoi: DrawString('Freehand'); RectRoi: DrawString('Rectangle'); OvalRoi: DrawString('Oval'); LineRoi: DrawString('Straight Line'); FreeLineRoi: DrawString('Freehand Line'); SegLineRoi: DrawString('Segmented Line'); end; NewLine; case RoiType of PolygonRoi, FreehandRoi, RectRoi, OvalRoi: with RoiRect do begin DrawBString(' Left: '); DrawXDimension(left, 0); NewLine; DrawBString(' Top: '); if InvertYCoordinates then DrawYDimension(PicRect.bottom - top - 1, 0) else DrawYDimension(top, 0); NewLine; DrawBString(' Width: '); DrawXDimension(right - left, 0); NewLine; DrawBString(' Height: '); DrawYDimension(bottom - top, 0); end; LineRoi: begin info := ImageInfo; GetLengthOrPerimeter(ulength, clength); GetLoi(x1, y1, x2, y2); Info := InfoWindowInfo; DrawBString(' Length: '); if SpatiallyCalibrated then begin DrawReal(cLength, 1, 2); DrawString(xUnit); end else DrawReal(uLength, 1, 2); NewLine; DrawBString(' Angle: '); DrawReal(LAngle, 1, 2); DrawString('°'); NewLine; DrawBString(' X1: '); DrawXDimension(x1, 2); NewLine; DrawBString(' Y1: '); if InvertYCoordinates then DrawYDimension(PicRect.bottom - y1 - 1, 2) else DrawYDimension(y1, 2); NewLine; DrawBString(' X2: '); DrawXDimension(x2, 2); NewLine; DrawBString(' Y2: '); if InvertYCoordinates then DrawYDimension(PicRect.bottom - y2 - 1, 2) else DrawYDimension(y2, 2); end; FreeLineRoi, SegLineRoi: begin info := ImageInfo; GetLengthOrPerimeter(ulength, clength); Info := InfoWindowInfo; DrawBString(' Length: '); if SpatiallyCalibrated then begin DrawReal(cLength, 1, 2); DrawString(xUnit); end else DrawReal(uLength, 1, 2); NewLine; end; otherwise end; {case} end else DrawBString('No Selection'); SetGDevice(SaveGDevice); end; {with ImageInfo^} SetForegroundColor(SaveForeIndex); SetBackgroundColor(SaveBackIndex); end; function NewPtrClear (blockSize: Size): Ptr; {This function will return a pointer of size specified and will} {clear the memory to zeros . This is done to create an empty bit} {map containing nothing but white bits . } {MOVE . L ( SP ) + , D0 ; get Size variable from stack} {_NewPtr , clear ; make pointer } {MOVE.L A0 , ( SP ) ; return pointer } {MOVE.W D0, MemErr ; set up MemErr } inline $201F, $A31E, $2E88, $31C0, $0220; function CheckIO (err: OSerr): integer; var ErrStr, Message: str255; ignore: integer; begin if err <> 0 then begin Message := ''; case err of -34: Message := 'Disk Full'; -36: Message := 'I/O Error'; -49: Message := 'File in Use'; -61: Message := 'Write Permission Error'; end; NumToString(err, ErrStr); ParamText(Message, ErrStr, '', ''); InitCursor; ignore := alert(IOErrorID, nil); macro := false; {If macro, abort it} end; CheckIO := err; end; function OpenMacPaint (fname: str255; vnum: integer): boolean; const MaxUnPackedSize = 51840; {Max MacPaint size in bytes=720 lines * 72 bytes/line } type mpLine = array[1..18] of LongInt; mpArrayT = array[1..720] of mpLine; mpArrayP = ^mpArrayT; var i, f, ScanLine, LastLine, LastWord, LastColumn: integer; err: osErr; srcSize: LongInt; srcPtr, dstPtr, src, dst: ptr; theBitMap: BitMap; mpArray: mpArrayP; BlankLine, BlankColumn: boolean; frect: rect; SaveGDevice: GDHandle; procedure abort; begin beep; if srcPtr <> nil then DisposPtr(srcPtr); if dstPtr <> nil then DisposPtr(dstPtr); exit(OpenMacPaint); end; begin OpenMacPaint := false; err := fsOpen(fname, vnum, f); if CheckIO(err) <> noErr then exit(OpenMacPaint); err := GetEOF(f, srcSize); srcSize := srcSize - 512; srcPtr := NewPtr(srcSize); if srcPtr = nil then abort; err := SetFPos(f, fsFromStart, 512); err := fsRead(f, srcSize, srcPtr); if CheckIO(err) <> noErr then exit(OpenMacPaint); err := fsClose(f); dstPtr := NewPtrClear(MaxUnPackedSize); if dstPtr = nil then abort; src := srcPtr; dst := dstPtr; for scanLine := 1 to 720 do UnPackBits(src, dst, 72); {bumps both ptrs} DisposPtr(srcPtr); mpArray := mpArrayP(dstPtr); LastLine := 720; BlankLine := true; repeat for i := 1 to 18 do blankLine := BlankLine and (mpArray^[LastLine, i] = 0); if BlankLine then LastLine := LastLine - 1; until (not BlankLine) or (LastLine = 1); LastWord := 18; BlankColumn := true; repeat for i := 1 to LastLine do blankColumn := BlankColumn and (mpArray^[i, LastWord] = 0); if BlankColumn then LastWord := LastWord - 1; until (not BlankColumn) or (LastWord = 1); LastColumn := LastWord * 32; LastColumn := LastColumn + 8; if LastColumn > 576 then LastColumn := 576; LastLine := LastLine + 8; if LastLine > 720 then LastLine := 720; SetRect(frect, 0, 0, LastColumn, LastLine); with theBitMap do begin baseAddr := dstPtr; rowBytes := 72; bounds := frect; end; if not NewPicWindow(fname, LastColumn, LastLine) then abort; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); with info^ do begin hlock(handle(osPort^.portPixMap)); CopyBits(theBitMap, BitMapHandle(osPort^.PortPixMap)^^, frect, frect, SrcCopy, nil); hunlock(handle(osPort^.PortPixMap)); DisposPtr(dstPtr); PictureType := imported; BinaryPic := true; SetGDevice(SaveGDevice); if PixMapSize > UndoBufSize then PutWarning; end; OpenMacPaint := true; end; procedure TypeMismatch (fname: str255); begin PutMessage(concat('The file "', fname, '" is a different type, and therefore cannot be replaced')); end; procedure SaveAsMacPaint (fname: str255; RefNum: integer); const MaxFileSize = 53072; { maximum MacPaint file size. } var TheInfo: FInfo; dstPtr, srcPtr, mpBufPtr: Ptr; i, f, scanLine, err, width, height: integer; dstBuffer: array[1..128] of LongInt; size, dstSize: LongInt; theBitMap: BitMap; mprect, srect, drect: rect; procedure abort; begin beep; if mpBufPtr <> nil then DisposPtr(mpBufPtr); if f <> -1 then err := fsclose(f); exit(SaveAsMacPaint); end; begin f := -1; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if fdType <> 'PNTG' then begin TypeMismatch(fname); exit(SaveAsMacPaint) end; end; FNFerr: begin err := create(fname, RefNum, 'MPNT', 'PNTG'); if CheckIO(err) <> 0 then exit(SaveAsMacPaint); end; otherwise if CheckIO(err) <> 0 then exit(SaveAsMacPaint); end; mpBufPtr := NewPtrClear(MaxFileSize); if mpBufPtr = nil then abort; ShowWatch; SetRect(mprect, 0, 0, 576, 720); with theBitMap do begin baseAddr := mpBufPtr; rowBytes := 72; bounds := mprect; end; with info^ do begin if roiShowing then srect := RoiRect else srect := PicRect; with srect do begin width := right - left; height := bottom - top; if width > 576 then width := 576; if height > 720 then height := 720; right := left + width; bottom := top + height; end; SetRect(drect, 0, 0, width, height); hlock(handle(osPort^.portPixMap)); CopyBits(BitMapHandle(osPort^.PortPixMap)^^, theBitMap, srect, drect, srcCopy, nil); hunlock(handle(osPort^.PortPixMap)); end; err := fsOpen(fname, RefNum, f); if CheckIO(err) <> noErr then abort; for I := 1 to 128 do dstBuffer[I] := 0; Size := 512; err := FSWrite(f, Size, @dstBuffer); if CheckIO(err) <> noErr then abort; srcPtr := theBitMap.baseAddr; for scanLine := 1 to 720 do begin dstPtr := @dstBuffer; { reset the pointer to bottom } PackBits(srcPtr, dstPtr, 72); { bumps both ptrs} dstSize := ord(dstPtr) - ord(@dstBuffer);{calc packed size} err := fsWrite(f, dstSize, @dstBuffer); if CheckIO(err) <> noErr then abort; end; err := fsclose(f); DisposPtr(mpBufPtr); info^.changes := false; end; function GetTextFile (var name: str255; var RefNum: integer): boolean; var where: Point; typeList: SFTypeList; reply: SFReply; err: OSErr; pBlock: WDPBRec; begin where.v := 120; where.h := 120; typeList[0] := 'TEXT'; SFGetFile(Where, '', nil, 1, typeList, nil, reply); if reply.good then with reply do begin name := fname; RefNum := vRefNum; GetTextFile := true; end else GetTextFile := false; end; procedure GetBuffer; var err: OSErr; count, FilePos: LongInt; begin count := MaxTextBufSize; err := fsread(Textf, count, ptr(TextBufP)); TextBufSize := count; err := GetFPos(Textf, FilePos); if FilePos = TextFileSize then begin TextBufSize := TextBufSize + 1; if TextBufSize > MaxTextBufSize then TextBufSize := MaxTextBufSize; TextBufP^[TextBufSize] := eof; err := fsclose(Textf); end; TextIndex := 1; end; function GetByte: char; begin GetByte := TextBufP^[TextIndex]; TextIndex := TextIndex + 1; if TextIndex > MaxTextBufSize then GetBuffer; end; function GetNumber: real; var c: char; str: str255; begin repeat c := GetByte; if c = tab then begin GetNumber := 0.0; {Assume 0 zero for missing value.} exit(GetNumber); end; if (c = cr) or (c = eof) then begin TextEol := true; TextEof := c = eof; GetNumber := NoValue; exit(GetNumber); end; until c in ['0'..'9', '-', '.']; Str := ''; while c in ['0'..'9', '+', '-', '.', 'e', 'E'] do begin Str := concat(str, c); c := GetByte; if (c = cr) or (c = eof) then begin TextEol := true; TextEof := c = eof; end; end; GetNumber := StringToReal(str); end; procedure GetLineFromText (var rLine: RealLine; var count: integer); var n: real; begin count := 0; if TextEof then exit(GetLineFromText); repeat n := GetNumber; if n <> NoValue then begin count := count + 1; rLine[count] := n; end; until TextEol or (count = MaxLine); TextEol := false; end; procedure InitTextInput (name: str255; RefNum: integer); var err: OSErr; begin err := FSOpen(name, RefNum, Textf); err := GetEof(Textf, TextFileSize); err := SetFPos(Textf, fsFromStart, 0); ShowWatch; if WhatsOnClip = TextOnClip then WhatsOnClip := NothingOnClip; GetBuffer; TextEol := false; TextEof := false; end; function ImportTextFile (name: str255; RefNum: integer): boolean; var nRows, nColumns, count, i, vloc, BlankPixel, nPixelsPerLine: integer; rLine: RealLine; pvalue: real; min, max, ScaleFactor, DefaultValue, tvalue: extended; err: OSErr; line, BlankLine: LineType; TheInfo: FInfo; begin ImportTextFile := false; err := GetFInfo(name, RefNum, TheInfo); if TheInfo.fdType <> 'TEXT' then begin PutMessage('File is not of type ''TEXT''.'); exit(ImportTextFile); end; InitTextInput(name, RefNum); nRows := 0; nColumns := 0; max := -10e-10; min := 10e10; ShowMessage(concat('First pass used to find ', cr, 'width, height,min, and max.', cr, cr, CmdPeriodToStop)); DrawLabels('Line:', '', ''); while not TextEof do begin GetLineFromText(rLine, count); if not (TextEof and (count = 0)) then nRows := nRows + 1; if count > nColumns then nColumns := count; for i := 1 to count do begin pvalue := rLine[i]; if pvalue > max then max := pvalue; if pvalue < min then min := pvalue; end; if nRows mod 10 = 0 then begin Show1Value(nRows, NoValue); if CommandPeriod then begin beep; err := fsclose(Textf); Exit(ImportTextFile); end; end; end; ShowMessage(concat('rows= ', long2str(nRows), cr, 'columns= ', long2str(ncolumns), cr, 'min= ', long2str(round(min)), cr, 'max= ', long2str(round(max)))); if nColumns > MaxLine then begin PutMessage('More than 2048 pixels per line.'); Exit(ImportTextFile); end; nPixelsPerLine := nColumns; if NewPicWindow(name, nPixelsPerLine, nrows) then with info^ do begin if (not ImportAutoScale) and (max > min) then begin min := ImportMin; max := ImportMax; end; ScaleFactor := 253.0 / (max - min); InitTextInput(name, RefNum); vloc := 0; DefaultValue := 0.0; if DefaultValue < min then DefaultValue := min; if DefaultValue > max then DefaultValue := max; BlankPixel := round((DefaultValue - min) * ScaleFactor + 1); for i := 0 to nColumns - 1 do BlankLine[i] := BlankPixel; DrawLabels('Line:', 'Total:', ''); while not TextEof do begin GetLineFromText(rLine, count); if not (TextEof and (count = 0)) then begin line := BlankLine; if ImportAutoScale then {Map values into the range 1-254} for i := 1 to count do line[i - 1] := round((rLine[i] - min) * ScaleFactor + 1) else for i := 1 to count do begin tvalue := rLine[i]; if tvalue < min then tvalue := min; if tvalue > max then tvalue := max; line[i - 1] := round((tvalue - min) * ScaleFactor + 1); end; PutLine(0, vloc, PixelsPerLine, line); vloc := vloc + 1; end; if vloc mod 10 = 0 then begin Show2Values(vloc, nRows); if CommandPeriod then begin beep; err := fsclose(Textf); Exit(ImportTextFile); end; end; end; fit := StraightLine; nCoefficients := 2; coefficient[2] := (max - min) / 253.0; coefficient[1] := min - coefficient[2]; DensityCalibrated := true; UpdateTitleBar; if macro then GenerateValues; ZeroClip := false; changes := true; PictureType := imported; end; {with} ImportTextFile := true; end; procedure PlotXYZ; {Reads X-Y coordinate pairs and optional intensiy(Z) values from a} {two or three column tab-delimited text file and plots them in the current window.} var fname, str: str255; RefNum, i, nColumns, nValues, index, wheight: integer; rLine: RealLine; begin RefNum := 0; if not GetTextFile(fname, RefNum) then exit(PlotXYZ); InitTextInput(fname, RefNum); GetLineFromText(rLine, nValues); nColumns := nValues; if not ((nColumns = 2) or (nColumns = 3)) then begin PutMessage('File must have two or three columns.'); exit(PlotXYZ); end; wheight := info^.nLines; index := ForegroundIndex; repeat if nColumns = 3 then begin index := round(rLine[3]); if index > 255 then index := 255; if index < 0 then index := 0; end; PutPixel(round(rLine[1]), wheight - round(rLine[2] + 1), index); GetLineFromText(rLine, nValues); until nValues = 0; InitCursor; end; {$IFC false} procedure SaveDefaultWorkingDir (var settings: SettingsType); var DefaultVRefNum, err: integer; DefaultDirID: LongInt; ProcID: LongInt; begin with settings do begin if DefaultRefNum <> 0 then begin err := GetWDInfo(DefaultRefNum, DefaultVRefNum, DefaultDirID, ProcID); if err = NoErr then begin sDefaultVRefNum := DefaultVRefNum; sDefaultDirID := DefaultDirID; end else beep; end; {ShowMessage(concat('KernelsRefNum=', long2str(KernelsRefNum), cr, 'vRefNum=', long2str(sKernelsVRefNum), cr, 'DirID=', long2str(sKernelsDirID)));} end; {with} end; procedure SaveKernelsWorkingDir (var settings: SettingsType); var KernelsVRefNum, err: integer; KernelsDirID: LongInt; ProcID: LongInt; begin with settings do begin if KernelsRefNum <> 0 then begin err := GetWDInfo(KernelsRefNum, KernelsVRefNum, KernelsDirID, ProcID); if err = NoErr then begin sKernelsVRefNum := KernelsVRefNum; sKernelsDirID := KernelsDirID; end else beep; end; {ShowMessage(concat('KernelsRefNum=', long2str(KernelsRefNum), cr, 'vRefNum=', long2str(sKernelsVRefNum), cr, 'DirID=', long2str(sKernelsDirID)));} end; {with} end; {$ENDC} procedure SaveSettings; var TheInfo: FInfo; ByteCount: LongInt; f, i: integer; err: OSErr; settings: SettingsType; begin with settings, info^ do begin sID := 'IMAG'; sVersion := version; sForegroundIndex := ForegroundIndex; sBackgroundIndex := BackgroundIndex; sBrushHeight := BrushHeight; sBrushWidth := BrushWidth; sSprayCanDiameter := SprayCanDiameter; sLUTMode := LUTMode; sOldColorStart := 30; sOldColorWidth := 10; sCurrentFontID := CurrentFontID; sCurrentStyle := CurrentStyle; sCurrentSize := CurrentSize; sTextJust := TextJust; sTextBack := TextBack; sNExtraColors := nExtraColors; sExtraColors := ExtraColors; sInvertVideo := InvertVideo; sMeasurements := Measurements; sInvertPlots := InvertPlots; sAutoScalePlots := AutoScalePlots; sLinePlot := LinePlot; sDrawPlotLabels := DrawPlotLabels; for i := 1 to 12 do sUnused1[i] := 0; sFixedSizePlot := FixedSizePlot; sProfilePlotWidth := ProfilePlotWidth; sProfilePlotHeight := ProfilePlotHeight; sFramesToAverage := FramesToAverage; sNewPicWidth := NewPicWidth; sNewPicHeight := NewPicHeight; sBufferSize := BufferSize; sMaxScionWidth := MaxScionWidth; sThresholdToForeground := ThresholdToForeground; sNonThresholdToBackground := NonThresholdToBackground; sVideoChannel := VideoChannel; sWhatToImport := WhatToImport; sImportCustomWidth := ImportCustomWidth; sImportCustomHeight := ImportCustomHeight; sImportCustomOffset := ImportCustomOffset; sWandAutoMeasure := WandAutoMeasure; sWandAdjustAreas := WandAdjustAreas; sBinaryIterations := BinaryIterations; sScaleArithmetic := ScaleArithmetic; sInvertPixelValues := InvertPixelValues; sInvertYCoordinates := InvertYCoordinates; sFieldWidth := FieldWidth; sPrecision := precision; sMinParticleSize := MinParticleSize; sMaxParticleSize := MaxParticleSize; sIgnoreParticlesTouchingEdge := IgnoreParticlesTouchingEdge; sLabelParticles := LabelParticles; sOutlineParticles := OutlineParticles; sIncludeHoles := IncludeHoles; sOscillatingMovies := OscillatingMovies; sDriverHalftoning := DriverHalftoning; sMaxMeasurements := MaxMeasurements; sImportCustomDepth := ImportCustomDepth; sImportSwapBytes := ImportSwapBytes; sImportCalibrate := ImportCalibrate; sImportAutoscale := ImportAutoscale; for i := 1 to 12 do sUnused2[i] := 0; sShowHeadings := ShowHeadings; sDefaultVRefNum := 0; sDefaultDirID := 0; sKernelsVRefNum := 0; sKernelsDirID := 0; {***} sProfilePlotMin := ProfilePlotMin; sProfilePlotMax := ProfilePlotMax; sImportMin := ImportMin; sImportMax := ImportMax; sHighlightPixels := HighlightSaturatedPixels; {***} sBallRadius := BallRadius; sFasterBackgroundSubtraction := FasterBackgroundSubtraction; sScaleConvolutions := ScaleConvolutions; {V1.42} sBinaryCount := BinaryCount; sColorTable := ColorTable; sColorStart := ColorStart; sColorEnd := ColorEnd; sInvertedTable := InvertedColorTable; {V1.44} sHalftoneFrequency := HalftoneFrequency; sHalftoneAngle := HalftoneAngle; sHalftoneDotFunction := HalftoneDotFunction; sLG3DacLow := LG3DacLow; sLG3DacHigh := LG3DacHigh; sSyncMode := SyncMode; sSwitchLUTOnSuspend := SwitchLUTOnSuspend; sVideoRateAveraging := VideoRateAveraging; sImportInvert := ImportInvert; sTextCreator := TextCreator; for i := 1 to 10 do sUnused[i] := 0; end; {with} {PBGetWDInfo seems to crash a lot, particularly under System 7. Does anyone know why?} {SaveDefaultWorkingDir(settings);} {SaveKernelsWorkingDir(settings);} err := GetFInfo(PrefsName, SystemRefNum, TheInfo); if err = FNFerr then begin err := create(PrefsName, SystemRefNum, 'Imag', 'PREF'); if CheckIO(err) <> 0 then exit(SaveSettings); end; err := fsopen(PrefsName, SystemRefNum, f); if CheckIO(err) <> 0 then exit(SaveSettings); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(settings); err := fswrite(f, ByteCount, @settings); if CheckIO(err) <> 0 then begin err := fsclose(f); exit(SaveSettings) end; err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, SystemRefNum); end; procedure ExportAsText (fname: str255; RefNum: integer); var err, f, width, hloc, vloc: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; AutoSelectAll: boolean; tLine: LineType; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportAsText) end; FNFerr: begin err := create(fname, RefNum, TextCreator, 'TEXT'); if CheckIO(err) <> 0 then exit(ExportAsText); end; otherwise if CheckIO(err) <> 0 then exit(ExportAsText) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportAsText); AutoSelectAll := not info^.RoiShowing; if AutoSelectAll then SelectAll(true); if TooWide then exit(ExportAsText); FileSize := 0; with info^.RoiRect do begin width := right - left; for vloc := top to bottom - 1 do begin GetLine(left, vloc, width, tLine); TextBufSize := 0; for hloc := 0 to width - 1 do begin PutLong(tLine[hloc], 0); if hloc <> (width - 1) then PutTab; end; PutChar(cr); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod then leave; end; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); end; if AutoSelectAll then KillRoi; end; procedure ExportCoordinates (fname: str255; RefNum: integer); var err, f, i, y: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; InvertY: boolean; begin if not CoordinatesAvailableMsg then begin exit(ExportCoordinates) end; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportCoordinates) end; FNFerr: begin err := create(fname, RefNum, TextCreator, 'TEXT'); if CheckIO(err) <> 0 then exit(ExportCoordinates); end; otherwise if CheckIO(err) <> 0 then exit(ExportCoordinates) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportCoordinates); FileSize := 0; InvertY := InvertYCoordinates and (Info <> NoInfo); with info^ do for i := 1 to nCoordinates do begin TextBufSize := 0; PutLong(xCoordinates^[i] + RoiRect.left, 0); PutTab; y := yCoordinates^[i] + RoiRect.top; if InvertY then y := PicRect.bottom - y - 1; PutLong(y, 0); PutChar(cr); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod then leave; end; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); end; procedure ExportMeasurements (fname: str255; RefNum: integer); const LinesPerPass = 25; var err, f, i, first, last: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportMeasurements) end; FNFerr: begin err := create(fname, RefNum, TextCreator, 'TEXT'); if CheckIO(err) <> 0 then exit(ExportMeasurements); end; otherwise if CheckIO(err) <> 0 then exit(ExportMeasurements) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportMeasurements); FileSize := 0; first := 1; last := LinesPerPass; repeat if last > mCount then last := mCount; CopyResultsToBuffer(first, last, ShowHeadings or OptionKeyWasDown); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod or (last = mCount) then leave; first := first + LinesPerPass; last := last + LinesPerPass; until false; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); UnsavedResults := false; end; procedure Swap2Bytes (var i: integer); type atype = packed array[1..2] of char; var a: atype; c: char; begin a := atype(i); c := a[1]; a[1] := a[2]; a[2] := c; i := integer(a) end; procedure Swap4Bytes (var i: LongInt); var a: ostype; c: char; begin a := ostype(i); c := a[1]; a[1] := a[4]; a[4] := c; c := a[2]; a[2] := a[3]; a[3] := c; i := LongInt(a) end; function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean; var TiffHeader: TiffHdr; ByteCount: LongInt; err: OSErr; begin ByteCount := 8; err := SetFPos(f, fsFromStart, 0); err := fsread(f, ByteCount, @TiffHeader); if CheckIO(err) <> NoErr then begin OpenTiffHeader := false; exit(OpenTiffHeader); end; with TiffHeader do begin IntelByteOrder := ByteOrder = 'II'; if (ByteOrder <> 'MM') and (ByteOrder <> 'II') then begin PutMessage('Invalid TIFF header.'); OpenTiffHeader := false; exit(OpenTiffHeader) end; DirOffset := FirstIFDOffset; if IntelByteOrder then Swap4Bytes(DirOffset); OpenTiffHeader := true; end; end; procedure GetTiffEntry (f: integer; var tag: integer; var N, value: LongInt); var IFDEntry: TiffEntry; ByteCount: LongInt; IntValue: integer; err: OSErr; str: str255; begin ByteCount := 12; err := FSRead(f, ByteCount, @IFDEntry); with IFDEntry do begin tag := TagField; N := length; if IntelByteOrder then begin Swap2Bytes(tag); Swap2Bytes(ftype); Swap4Bytes(N); end; value := offset; if (ftype = short) and (N = 1) then begin value := bsr(value, 16); if IntelByteOrder then begin IntValue := value; Swap2Bytes(IntValue); value := IntValue end end else if IntelByteOrder then Swap4Bytes(value); if OptionKeyWasDown then begin gstr := concat(gstr, long2str(tag), ' ', long2str(ftype), ' ', long2str(N), ' ', long2str(value), cr); ShowMessage(gstr); end; end; end; function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean; const NoUnit = 1; inch = 2; centimeter = 3; var ByteCount, length, ftype, N, value, BytesPerStrip, SaveFPos: LongInt; err: OSErr; nEntries, i, tag, entry: integer; StripOffsetsArray: array[1..2] of LongInt; xRes, yRes: extended; function GetResolution: extended; var resolution: array[1..2] of LongInt; begin err := GetFPos(f, SaveFPos); err := SetFPos(f, fsFromStart, value); ByteCount := 8; err := fsread(f, ByteCount, @Resolution); if IntelByteOrder then begin Swap4Bytes(Resolution[1]); Swap4Bytes(Resolution[2]); end; err := SetFPos(f, fsFromStart, SaveFPos); if resolution[2] <> 0 then GetResolution := resolution[1] / resolution[2] else GetResolution := 0.0; end; begin if OptionKeyWasDown then gstr := ''; xRes := 0.0; err := SetFPos(f, fsFromStart, DirOffset); ByteCount := 2; err := FSRead(f, ByteCount, @nEntries); if CheckIO(err) <> NoErr then begin OpenTiffDirectory := false; exit(OpenTiffDirectory); end; if IntelByteOrder then Swap2Bytes(nEntries); with TiffInfo do begin width := 0; height := 0; BitsPerPixel := 1; OffsetToData := 0; Resolution := 0.0; ResUnits := tNoUnits; OffsetToColorMap := 0; OffsetToImageHeader := -1; for entry := 1 to nEntries do begin GetTiffEntry(f, tag, N, value); if tag = 0 then begin PutMessage('Invalid TIFF format.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; case tag of ImageWidth: width := value; ImageLength: height := value; BitsPerSample: begin BitsPerPixel := value; if value = 1 then begin PutMessage('NIH Image cannot open 1-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; if (value = 16) and not importing then begin PutMessage('Use Import to open 16-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; end; SamplesPerPixel: if value > 1 then begin PutMessage('NIH Image cannot open 24-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; Compression: if value <> 1 then begin PutMessage('NIH Image cannot open compressed TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; PhotoInterp: ZeroIsBlack := value = 1; StripOffsets: if N = 1 then OffsetToData := value else begin err := GetFPos(f, SaveFPos); err := SetFPos(f, fsFromStart, value); ByteCount := 8; err := fsread(f, ByteCount, @StripOffsetsArray); if IntelByteOrder then begin Swap4Bytes(StripOffsetsArray[1]); Swap4Bytes(StripOffsetsArray[2]); end; err := SetFPos(f, fsFromStart, SaveFPos); end; RowsPerStrip: if value < height then begin if BitsPerPixel = 16 then BytesPerStrip := value * width * 2 else BytesPerStrip := value * width; if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin PutMessage('NIH Image cannot open TIFF files with discontiguous strips.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; OffsetToData := StripOffsetsArray[1]; end; XResolution: XRes := GetResolution; YResolution: begin yRes := GetResolution; if (xRes = yRes) and (xRes > 0.0) then begin resolution := xRes; ResUnits := tInches; end; end; ResolutionUnit: case value of NoUnit: ResUnits := tNoUnits; Centimeter: ResUnits := tCentimeters; otherwise end; ColorMapTag: if N = 768 then OffsetToColorMap := value; ImageHdrTag: OffsetToImageHeader := value; otherwise end; end; {for} ByteCount := 4; err := FSRead(f, ByteCount, @NextIFD); if IntelByteOrder then Swap4Bytes(NextIFD); if OptionKeyWasDown then begin gstr := concat(gstr, 'Next IFD=', long2str(NextIFD)); ShowMessage(gstr); end; if width = 0 then begin PutMessage('Error opening TIFF directory'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; end; {with} OpenTiffDirectory := true; end; procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt); var i: integer; err: OSErr; ColorMap: TiffColorMapType; ColorMapSize: LongInt; begin LoadLUT(info^.cTable); for i := 0 to 255 do with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin ColorMap[1, i] := red; ColorMap[2, i] := green; ColorMap[3, i] := blue; end; err := SetFPos(f, FSFromStart, HeaderSize + TiffDirSize + ImageDataSize); ColorMapSize := SizeOf(ColorMap); err := fswrite(f, ColorMapSize, @ColorMap); if CheckIO(err) <> 0 then beep; end; procedure GetTiffColorMap (f: integer); var i: integer; ByteCount: LongInt; err: OSErr; ColorMap: TiffColorMapType; begin with info^ do begin ByteCount := SizeOf(ColorMap); err := SetFPos(f, fsFromStart, ColorMapOffset); err := fsRead(f, ByteCount, @ColorMap); if err = NoErr then begin if IntelByteOrder then for i := 0 to 255 do begin Swap2Bytes(ColorMap[1, i]); Swap2Bytes(ColorMap[2, i]); Swap2Bytes(ColorMap[3, i]); end; for i := 0 to 255 do with cTable[i].rgb do begin red := ColorMap[1, i]; green := ColorMap[2, i]; blue := ColorMap[3, i]; end; LoadLUT(cTable); LUTMode := ColorLut; SetupPseudocolor; IdentityFunction := false; if isGrayScaleLUT then begin info^.LutMode := CustomGrayScale; DrawMap; end; end else beep; end;{with} end; function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr; var i: integer; err: OSErr; ByteCount, width, height: LongInt; TiffInfo1: record Header: TiffHdr; {8} nEntries: integer; {2} TiffDir: array[1..8] of TiffEntry; {96} end; ColorMapEntry: TiffEntry; {12(Optional)} TiffInfo2: record ImageHdrEntry: TiffEntry; {12} NextIFD: LongInt; {4} filler: array[1..TiffFillerSize] of integer; {134} end; begin with info^ do begin if SavingSelection then begin width := sPixelsPerLine; height := sLines end else begin width := PixelsPerLine; height := nLines end; with TiffInfo1 do begin with header do begin ByteOrder := 'MM'; Version := 42; FirstIFDOffset := 8; end; if ctabSize > 0 then nEntries := 10 else nEntries := 9; for i := 1 to 8 do with TiffDir[i] do begin ftype := 3; length := 1 end; with TiffDir[1] do begin TagField := NewSubfileType; ftype := 4; offset := 0; end; with TiffDir[2] do begin TagField := ImageWidth; offset := bsl(width, 16); end; with TiffDir[3] do begin TagField := ImageLength; offset := bsl(height, 16); end; with TiffDir[4] do begin TagField := BitsPerSample; offset := bsl(8, 16); end; with TiffDir[5] do begin TagField := PhotoInterp; if ctabSize > 0 then offset := bsl(3, 16) else offset := 0; end; with TiffDir[6] do begin TagField := StripOffsets; ftype := 4; offset := TiffDirSize + HeaderSize; end; with TiffDir[7] do begin TagField := RowsPerStrip; offset := bsl(height, 16); end; with TiffDir[8] do begin TagField := StripByteCount; ftype := 4; offsetname, RefNum); exit(SaveLUT) end; err := SetEof(f, ByteCount); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; procedure SaveColorTable (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; i, f: integer; ByteCount: LongInt; hdr: PaletteHeader; begin with info^ do err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'ICOL' then begin TypeMismatch(fname); exit(SaveColorTable) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'ICOL'); if CheckIO(err) <> 0 then exit(SaveColorTable); end; otherwise if CheckIO(err) <> 0 then exit(SaveColorTable); end; with info^ do begin InitPaletteHeader(hdr); err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveColorTable); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(PaletteHeader); if ByteCount <> 32 then PutMessage('Palette header size <> 32.'); err := fswrite(f, ByteCount, @hdr); ByteCount := nColors; err := fswrite(f, ByteCount, @redLUT); ByteCount := nColors; err := fswrite(f, ByteCount, @greenLUT); ByteCount := nColors; err := fswrite(f, ByteCount, @blueLUT); if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveColorTable) end; err := SetEOF(f, SizeOf(PaletteHeader) + 3 * nColors); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; {with info^} end; procedure SaveOutline (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; i, f: integer; ByteCount, DataSize: LongInt; hdr: RoiHeader; SaveCoordinates: boolean; begin with info^ do begin if not RoiShowing then begin PutMessage('No outline available to save.'); exit(SaveOutline); end; if (RoiType = FreeLineRoi) or (RoiType = SegLineRoi) then begin PutMessage('Freehand and segmented line selections cannot be saved.'); exit(SaveOutline); end; SaveCoordinates := (RoiType = PolygonRoi) or (RoiType = FreehandRoi); if SaveCoordinates then if not CoordinatesAvailableMsg then begin exit(SaveOutline); end; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'Iout' then begin TypeMismatch(fname); exit(SaveOutline) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'Iout'); if CheckIO(err) <> 0 then exit(SaveOutline); end; otherwise if CheckIO(err) <> 0 then exit(SaveOutline); end; with hdr do begin rID := 'Iout'; rVersion := version; rRoiType := RoiType; rRoiRect := RoiRect; rNCoordinates := nCoordinates; GetLoi(rX1, rY1, rX2, rY2); rLineWidth := LineWidth; for i := 1 to 14 do rUnused[i] := 0; end; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveOutline); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(RoiHeader); if ByteCount <> 64 then PutMessage('Roi header size <> 32.'); err := fswrite(f, ByteCount, @hdr); if SaveCoordinates then begin ByteCount := nCoordinates * 2; err := fswrite(f, ByteCount, ptr(xCoordinates)); ByteCount := nCoordinates * 2; err := fswrite(f, ByteCount, ptr(yCoordinates)); DataSize := nCoordinates * 4; end else DataSize := 0; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveOutline) end; err := SetEOF(f, SizeOf(RoiHeader) + DataSize); err := fsclose(f); err := GKind := Micrometers; UnitsPerCm := 10000.0; end else if xUnit = 'mm' then begin UnitsKind := Millimeters; UnitsPerCm := 10.0; end else if xUnit = 'cm' then begin UnitsKind := Centimeters; UnitsPerCm := 1.0; end else if xUnit = 'meter' then begin UnitsKind := Meters; UnitsPerCm := 0.01; end else if xUnit = 'km' then begin UnitsKind := Kilometers; UnitsPerCm := 0.00001; end else if xUnit = 'inch' then begin UnitsKind := Inches; UnitsPerCm := 0.3937; end else if xUnit = 'ft' then begin UnitsKind := feet; UnitsPerCm := 0.0328083; end else if xUnit = 'mile' then begin UnitsKind := Miles; UnitsPerCm := 0.000006213; end else if xUnit = 'pixel' then begin UnitsKind := pixels; UnitsPerCm := 0.0; SpatiallyCalibrated := false; end else begin UnitsKind := OtherUnits; UnitsPerCm := 0.0; end; end; end; end.